home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / makeicon < prev    next >
Encoding:
Text File  |  1989-06-08  |  1.6 KB  |  51 lines
  1.  
  2. \ Create icons when SAVE-FORTHing.
  3. \
  4. \   The SAVE-FORTH and SAVE-IMAGE
  5. \ utilities check if they can open 'fd:j.info' and if so,
  6. \ copies it to the same directory thaT the image is being saved to,
  7. \ giving it the same name with a '.info' appended.
  8. \
  9. \   If it can't find the file, it doesn't create an icon, but no error
  10. \ message is displayed.
  11. \
  12. \   This scheme has several advantages...dictionary not used to hold
  13. \ a 'master' copy...the programmer may change the ICON used simply by
  14. \ creating his own with 'ICONED' and copying it to 'fd:j.info'...invisible
  15. \ to the programmer...little code...etc.
  16. \
  17. \ 00001 05-may-89 mdh replaced two ! words with ABS! ( was a scribble!!! )
  18. \                     use CALLVOID at end.
  19.  
  20.  
  21. decimal
  22.  
  23. .need +null
  24. : +null  ( $adr -- )  count + 0 swap c!  ;
  25. .then
  26.  
  27. : HAVE-ICON?  ( -- flag )
  28.   dos0 1-  pad $move
  29.   " .info" count pad $append
  30.   pad +null
  31.   pad 1+ (fopen) dup
  32.   IF     dup fclose
  33.   THEN   ;
  34.  
  35. : MAKEICON  ( -- , pathname at dos0 )
  36.   have-icon? 0=
  37.   IF   
  38.        icon?  \ Make sure lib is open
  39.        0" fd:j"   >abs  call icon_lib GetDiskObject   -dup
  40.        IF
  41.             \ found master file, make filename at pad...
  42.             ( -- ABS&DiskObject )
  43.             \ init it so that Intuition will Auto-Locate it.
  44.             $ 8000,0000 over 58 +  ( offset to do_CurrentX )
  45.             ( 00001 ) 2dup abs!  cell+ abs!   ( pokes do_CurrentY, too! )
  46.             dos0 >abs over    ( -- ABS&Object ABSname ABS&Object )
  47.             call icon_lib PutDiskObject drop
  48.             ( -- &Object )  callvoid icon_lib FreeDiskObject  ( 00001 )
  49.        THEN
  50.   THEN ;
  51.